(defpackage :tag-pool
  (:use :cl :doplus)
  (:export #:deftag #:tag #:out #:fmt #:dotags #:emit-constant-string #:emit-expression
           #:requires-end-tag? #:tag-attributes
           #:emit #:emit-tag-body-form #:emit-tag-attribute #:emit-extra-tag-attributes
           #:*output-encoding* #:*tag-output-stream*
           ;;Utility stuff
           #:split-tag-arglist #:with-html-output-to-string))

(in-package :tag-pool)

(defvar *constant-string* nil "During macroexpansion, this variable is used to coalesce operations that output a constant string into a single output operation.")

(defvar *tag-output-stream* 'you-must-rebind-tag-output-stream "The stream code generated by tag macros writes to.")

(defvar *output-encoding* :utf-8 "The character encoding used when printing to the output stream. NIL means no encoding; in that case, the stream must be a character output stream. Otherwise, the stream must be a binary output stream.")

(defvar *environment*) ;;TODO doc

(defun %emit-string (str)
  (princ str *tag-output-stream*))

(defun %emit-octets (seq)
  (write-sequence seq *tag-output-stream*))

(defvar *emit-string-function* '%emit-string)

(defvar *emit-octets-function* '%emit-octets)

(defmacro dokeywords (args (key value) &body body)
  "Iterates over a list of keywords (<args>), binding <key> and <value> to each successive keyword-value pair in the list, and evaluating <body> at each iteration."
  (let ((args-var (gensym)))
    `(let ((,args-var ,args))
       (do+ ((for ,key (in-list ,args-var :by #'cddr))
             (for ,value (in-list (cdr ,args-var) :by #'cddr)))
         ,@body))))

(defmacro emit-expression (expr)
  "Generates code to print the result of evaluating an expression to *tag-output-stream*. If the expression evaluates to NIL, nothing is output."
  (let ((g (gensym)))
    `(let ((,g ,expr))
       (when ,g
         ,(if (null *output-encoding*)
              `(,*emit-string-function* ,g)
              `(,*emit-octets-function* (babel:string-to-octets (princ-to-string ,g) :encoding ,*output-encoding*))))
       t)))

(defmacro emit-constant-string (str)
  "Generates code to print the constant string <str> to *tag-output-stream*. If the string is empty, no code is generated."
  (when (and str (> (length str) 0))
    `(progn
       ,(if (null *output-encoding*)
            `(,*emit-string-function* ,str)
            `(,*emit-octets-function* ,(babel:string-to-octets str :encoding *output-encoding*)))
       t)))

(defclass tag ()
  ((attributes :initform (list) :accessor tag-attributes))
  (:documentation "Represents a XML or HTML tag at macroexpansion time. The main use of this class is to specialize the generic functions that make up the CLOS-based tag generation protocol. However, instances of this class also carry some information about the tag being output; that information can be used by specialized methods to perform their work."))

(defgeneric emit-start-tag (tag)
  (:documentation "Generates code to emit the first characters of a tag, before the attributes; that is, by default, the less-than symbol (<) and the lowercased tag name."))

(defmethod emit-start-tag ((tag tag))
  (append
   (emit "<")
   (emit (string-downcase (symbol-name (tag-name tag))))))

(defgeneric emit-tag-attribute (tag attr value)
  (:documentation "Generates code to print a single attribute (name-value pair). If the value is null at macroexpansion time, no code is generated. If the value is null at runtime, the default behaviour is to suppress output for that attribute, but methods are allowed to behave differently."))

(defmethod emit-tag-attribute ((tag tag) (attr symbol) value)
  (if (constantp value)
    (let ((value (eval value)))
      (when value
        (append
         (emit (format nil " ~A=\"" (string-downcase (symbol-name attr))))
         (emit value)
         (emit "\""))))
    (let ((var (gensym "VALUE")))
      `(let ((,var ,value))
         ,(emit-flush)
         (when ,var
           ,(append
             (emit (format nil " ~A=\"" (string-downcase (symbol-name attr))))
             (emit var)
             (emit "\""))
           ,(emit-flush))))))

(defgeneric emit-extra-tag-attributes (tag)
  (:documentation "Hook for tag implementations that want to generate additional attributes programmatically. The default method does nothing."))

(defmethod emit-extra-tag-attributes ((tag tag))
  (declare (ignore tag))
  nil)

(defgeneric emit-start-tag-body (tag)
  (:documentation "Generates code to emit the start of a tag's body. The default method just prints the greater-than symbol (>)."))

(defmethod emit-start-tag-body ((tag tag))
  (declare (ignore tag))
  (emit ">"))

(defgeneric emit-tag-body-form (tag form)
  (:documentation "Generates code to process a single form in a tag's body. Normally, emit-form is called on the form, but methods can override this behaviour; for example, the script tag can be enhanced to automatically translate its body with Parenscript and output the resulting JavaScript code."))

(defmethod emit-tag-body-form ((tag tag) form)
  (declare (ignore tag))
  (emit-form form))


(defgeneric requires-end-tag? (tag)
  (:documentation "Returns true iff the tag always requires a full end tag (</tag>) or can be terminated with \"/>\" if it has an empty body. The default method returns T."))

(defmethod requires-end-tag? ((tag tag))
  t)

(defgeneric emit-end-tag (tag bodyp)
  (:documentation "Generates code to close a tag. The bodyp parameter is true iff the tag has a non-empty body. The default method emits </tag> if bodyp is true or (requires-end-tag? tag) returns true; otherwise, it emits \" />\""))

(defmethod emit-end-tag ((tag tag) bodyp)
  (if (or bodyp (requires-end-tag? tag))
      (emit (format nil "</~A>" (string-downcase (symbol-name (tag-name tag)))))
      (emit " />")))

(defun check-tag-context ()
  "Utility function that checks whether a proper context for generating output code is established. If not, it raises an error, so that macroexpansion is aborted early."
  (when (not (stringp *constant-string*))
    (error "call outside of a tag macro")))

(defun emit (str)
  "Generates code to print a string to the output stream. If str is constant, it is coerced to a string (with princ-to-string) and concatenated to *constant-string*; the actual output code will be generated later. If str is a non-constant expression, a flush of the accumulated constant string is issued, and code to print str is generated."
  (check-tag-context)
  (if (constantp str)
      (progn
        (setf *constant-string* (concatenate 'string *constant-string*
                                             (princ-to-string str)))
        nil)
      `(progn
         ,(emit-flush)
         (emit-expression ,str))))

(defun emit-flush ()
  "Issues a flush of the accumulated constant string, i.e., it generates code to print its current value to the output stream and then resets it to an empty string."
  (check-tag-context)
  (prog1
      `(emit-constant-string ,*constant-string*)
    (setf *constant-string* "")))

(defun emit-form (form)
  "Generates code to output the result of evaluating an arbitrary form, following these rules:

 * If the form is identified as a call to a tag macro, it is expanded in the current environment.
 * If the form is a constant string, it is appended to *constant-string* by calling emit.
 * Else, a flush is emitted if necessary, and the form is included as-is in the generated code.

These rules assure that constant strings are coalesced as much as reasonably possible."
  (cond ((and (consp form)
              (symbolp (car form))
              (tagp (car form)))
         (macroexpand form *environment*))
        ((stringp form) (emit form))
        (t
         (if (= 0 (length *constant-string*))
             form
             `(progn
                ,(emit-flush)
                ,form)))))

(defmacro with-html-output-to-string ((var &rest args) &body body)
  "Evaluates its body in an environment where the output encoding is ignored and all tag output goes to a string. This is useful to experiment with code at the REPL. var and args are passed as-is to with-output-to-string."
  `(with-output-to-string (,var ,@args)
     (let ((*tag-output-stream* ,var))
       (macrolet ((emit-expression (str)
                    (let ((g (gensym)))
                      `(let ((,g ,str))
                         (when ,g (princ ,g *tag-output-stream*))
                         t)))
                  (emit-constant-string (str)
                    (when (and str (> (length str) 0))
                      `(princ ,str *tag-output-stream*))))
         ,@body))))

;;Tag definition

(defvar *tags* nil)

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defun merge-arglist-with-defaults (arglist defaults)
    "Integrates the list of arguments passed to a tag with the defaults for that tag: if a default attribute is not overridden, it is added to the list as if it was passed by the user."
    (let ((arg-names (loop :for x :in arglist :by #'cddr :collect x))
          (added-attrs))
      (do+ ((for _ (in-list defaults :rest defs :by #'cddr)))
        (unless (member (car defs) arg-names)
          (push (cadr defs) added-attrs)
          (push (car defs) added-attrs)))
      (append arglist added-attrs)))
  (defun split-tag-arglist (arglist &optional defaults)
    "Splits the list of arguments passed to a tag into an attributes part and a body part. Attributes are key-value pairs where the key is a symbol."
    (when arglist
      (let ((attr-list (list)) body)
        (do+ ((for _ (in-list arglist :rest rest :by #'cddr)))
          (if (and (symbolp (first rest)) (cdr rest))
              (progn
                (push (second rest) attr-list) ;attribute order should not matter
                (push (first rest) attr-list))
              (progn
                (setq body rest)
                (terminate))))
        (values (merge-arglist-with-defaults attr-list defaults) body)))))

(defmacro deftag (name &key (class name class-p) default-attributes)
  "Defines a new tag macro." ;;TODO doc!
  (let ((tag (gensym "TAG")))
    `(progn
       (defmacro ,name (&rest args &environment env)
         (multiple-value-bind (attrs body)
             (split-tag-arglist args ',default-attributes)
           (let ((,tag (make-instance ',class))
                 (*environment* env))
             (dokeywords attrs (key value)
               (push (cons key value) (tag-attributes ,tag)))
             (flet ((generate-body ()
                      (let (full-body)
                        (push (emit-start-tag ,tag) full-body)
                        (dokeywords attrs (key value)
                          (push (emit-tag-attribute ,tag key value) full-body))
                        (push (emit-extra-tag-attributes ,tag) full-body)
                        (when (or body (requires-end-tag? ,tag))
                          (push (emit-start-tag-body ,tag) full-body))
                        (when body
                          (dolist (form body)
                            (push (emit-tag-body-form ,tag form) full-body)))
                        (push (emit-end-tag ,tag (not (null body))) full-body)
                        (nreverse (delete nil full-body)))))
               (if (null *constant-string*)
                   (let* ((*constant-string* "")
                          (body (generate-body)))
                     (if body
                         `(progn
                            ,@body
                            ,(emit-flush))
                         (emit-flush)))
                   (let ((body (generate-body)))
                     (if (cdr body)
                         `(progn ,@body)
                         (car body))))))))
       ,(unless class-p
          `(defclass ,name (tag) ()))
       (setf (get ',name 'tag) t)
       (pushnew ',name *tags*)
       ',name)))

;(defclass dynamic-tag (tag)

(defun tagp (symbol)
  (get symbol 'tag))

(defun tag-name (tag)
  (class-name (class-of tag)))

(defmacro dotags ((var) &body body)
  `(dolist (,var *tags*)
     ,@body))

;;;Tags

(deftag out)

(defmethod emit-start-tag ((tag out))
  (declare (ignore tag)))
(defmethod emit-start-tag-body ((tag out))
  (declare (ignore tag)))
(defmethod emit-tag-body-form ((tag out) form)
  (declare (ignore tag))
  (emit form)) ;;TODO optional escaping
(defmethod emit-end-tag ((tag out) bodyp)
  (declare (ignore tag bodyp)))

(defmacro fmt (format-string &rest args)
  `(out (format nil ,format-string ,@args)))